home *** CD-ROM | disk | FTP | other *** search
/ FM Towns: Free Software Collection 8 / FM Towns Free Software Collection 8.iso / t_os / socio / socio.bas < prev    next >
BASIC Source File  |  1994-06-01  |  12KB  |  314 lines
  1. 10 ' ############################################################
  2. 20 ' #                ソシオメトリー                            #
  3. 30 ' #                                                          #
  4. 40 ' #        開発 MZ-731      昭和５８年                       #
  5. 50 ' #        移植 FM-7        昭和５９年（打ち直し）           #
  6. 60 ' #             PC8801mk2SR 昭和６１年（ＲＳ－２３２Ｃ）     #
  7. 70 ' #             PC9801VM2   昭和６２年（コンバータ)          #
  8. 80 ' #             FM-16β     昭和６２年（エデイタ）           #
  9. 90 ' #        修正完了         昭和６３年４月                   #
  10. 100 '#                                                          #
  11. 110 '#        著作権保持者　   後藤勝美                         #
  12. 120 '#                                                          #
  13. 130 '############################################################
  14. 140 CLEAR:CONSOLE 0,24,1:DEFINT A-Z:COLOR 7,0:CLS
  15. 150 J=2:K=5
  16. 160 '
  17. 170 GOSUB *INITIALIZE
  18. 180 PRINT:INPUT"印刷時のタイトルを入力してください       ";TI$
  19. 190 INPUT"選択制限数(何名まで選択させるか)は       ";D
  20. 200 INPUT"調査表を作成しますか（ﾌﾟﾘﾝﾀｰ用意）　(Y/N)";S$
  21. 210 '----- SCREEN -----
  22. 220 CLS
  23. 230 IF S$="Y" OR S$="y" THEN CONSOLE 0,24,0
  24. 240 IF M>=(W-M) THEN L=INT(M/2-.5!)+5
  25. 250 IF (W-M)>M THEN L=INT((W-M)/2-.5!)+5
  26. 260 LOCATE 5,3:PRINT"         ****** データを入力してください ******":Y=1
  27. 270 IF Y=W+1 THEN Y=1
  28. 280 IF Y=0 THEN Y=W
  29. 290 LOCATE 0,0:PRINT"  ";N$(Y);:COLOR 2
  30. 300 PRINT"  が好きな者     ":COLOR 7
  31. 310 Z=1:GOTO 360
  32. 320 LOCATE 0,0:PRINT"  ";N$(Y);:COLOR 1
  33. 330 PRINT"  が嫌いな者     ":COLOR 7
  34. 340 Z=-1
  35. 350 '--- NAME ----
  36. 360 P=0:Q=5
  37. 370 FOR A=1 TO W
  38. 380 LOCATE P,Q
  39. 390 IF Y(Y,A)=1 AND Z=1 THEN COLOR 2
  40. 400 IF Y(Y,A)=-1 AND Z=-1THEN COLOR 1
  41. 410 PRINT USING"##";A;
  42. 420 COLOR 7,0:PRINT" ";N$(A)
  43. 430 IF Q=L THEN P=P+19:Q=5 ELSE Q=Q+1
  44. 440 IF A=M THEN P=38:Q=5
  45. 450 NEXT
  46. 460 BEEP:IF S$="Y" OR S$="y" THEN *TYOUSA
  47. 470 'LINE(0,330)-(639,380),PSET,7,B
  48. 480 'PAINT(10,370),4,7
  49. 490 LOCATE 0,21
  50. 500 PRINT"    E:終了  M:資料ﾏﾄﾘｸｽ  G:ｿｼｵｸﾞﾗﾑ     S:調査ﾃﾞｰﾀ登録  *:次(の子)へ"
  51. 510 PRINT"    Z:前者  N:名簿登録　 A:転入者追加  D:転出者抹消    B:ﾃﾞｰﾀ修正"
  52. 520 S$="":GOTO *SELECT
  53. 530 '--- ｼﾘｮｳ ﾏﾄﾘｸｽ ----
  54. 540 LOCATE 0,19:INPUT"資料マトリクスをプリントしますか(Y/N) ";Y$
  55. 550 IF Y$="Y" OR Y$="y" THEN 560 ELSE 860
  56. 560 LOCATE 0,19:PRINT SPACE$(70)
  57. 570 LOCATE 0,19:INPUT"プリンターをセットしましたか    (Y/N) ";Y$
  58. 580 LPRINT"< 資料マトリクス >  ";TI$
  59. 590 L1$="                     11111111112222222222333333333344444444445"
  60. 600 L2$="            12345678901234567890123456789012345678901234567890"
  61. 610 M1$=LEFT$(L1$,W+12)
  62. 620 M2$=LEFT$(L2$,W+12)
  63. 630 LPRINT
  64. 640 LPRINT M1$
  65. 650 LPRINT M2$;
  66. 660 LPRINT"  C  R  CRS mc mr  Isss"
  67. 670 FOR Q=1 TO W
  68. 680  LPRINT USING"##";Q;:LPRINT USING"&        &";N$(Q);
  69. 690  FOR P=1 TO W
  70. 700   IF Y(P,Q)=1 AND Y(Q,P)=1 THEN LPRINT"L";:C=C+1:MC=MC+1:GOTO 750
  71. 710   IF Y(P,Q)=1 THEN LPRINT"o";:C=C+1:GOTO 750
  72. 720   IF Y(P,Q)=-1 AND Y(Q,P)=-1 THEN LPRINT"H";:R=R+1:MR=MR+1:GOTO 750
  73. 730   IF Y(P,Q)=-1 THEN LPRINT"x";:R=R+1:GOTO 750
  74. 740   LPRINT"･";
  75. 750  NEXT P
  76. 760  LPRINT USING" ## ## #### ## ## ####.##";C;R;C-R;MC;MR;((C-R)/(W-1)+(MC-MR)/D)/2*1000
  77. 770  C(Q)=C:R(Q)=R:CRS(Q)=C(Q)-R(Q)
  78. 780  C=0:R=0:CRS=0:MC=0:MR=0
  79. 790 NEXT Q
  80. 800 LPRINT:LPRINT
  81. 810 LPRINT"o：選択　　x：排除　　L：相互選択　　H：相互排除"
  82. 820 LPRINT"C：選択数　R：排除数　C-R：差引     mc：相互選択数  mr：相互排除数"
  83. 830 LPRINT"Isss(x1000)：地位指数"
  84. 840 LPRINT:LPRINT"COMPLEET !":BEEP
  85. 850 A=1:Y$="":RETURN 210
  86. 860 LOCATE 0,19:PRINT SPACE$(40):RETURN 1110
  87. 870 '--- 構造マトリクス -----
  88. 880 '
  89. 890 '
  90. 900 '
  91. 910 '
  92. 920 '
  93. 930 '
  94. 940 '----- SELECTION --------------------------
  95. 950 *SELECT
  96. 960 LOCATE 0,19:PRINT SPACE$(70)
  97. 970 LOCATE 0,19:INPUT"御命令を";MEI$
  98. 980 IF MEI$="B" OR MEI$="b" THEN GOSUB 2140
  99. 990 IF MEI$="M" OR MEI$="m" THEN GOSUB 540
  100. 1000 IF MEI$="G" OR MEI$="g" THEN GOSUB 1280
  101. 1010 IF MEI$="S" OR MEI$="s" THEN GOSUB 2840
  102. 1020 IF MEI$="*" OR MEI$="*" THEN GOTO 1240
  103. 1030 IF MEI$="Z" OR MEI$="z" THEN GOSUB 1260
  104. 1040 'IF MEI$="K" THEN GOSUB 900
  105. 1050 IF MEI$="A" OR MEI$="a" THEN GOSUB 1680
  106. 1060 IF MEI$="D" OR MEI$="d" THEN GOSUB 1940
  107. 1070 IF MEI$="I" OR MEI$="i" THEN GOSUB 3060
  108. 1080 IF MEI$="E" OR MEI$="e" THEN GOTO *END
  109. 1090 IF MEI$="N" OR MEI$="n" THEN GOSUB 2600
  110. 1100 LOCATE 0,19:PRINT"                       "
  111. 1110 G=VAL(MEI$):MEI$=""
  112. 1120 IF G<=0 THEN G=0:MEI$="":GOTO *SELECT
  113. 1130 IF G<=(L-4) THEN LOCATE 0,G+4:GOTO 1180
  114. 1140 IF G<=M THEN LOCATE 19,G-L+8:GOTO 1180
  115. 1150 IF G<=(M+L-4) THEN LOCATE 38,G-M+4:GOTO 1180
  116. 1160 IF G>W THEN GOTO *SELECT
  117. 1170 LOCATE 57,G-M-L+8:GOTO 1180
  118. 1180 IF G=Y THEN G=0:MEI$="":GOTO *SELECT
  119. 1190 IF Z=1 THEN COLOR 2:PRINT USING"##";G:Y(Y,G)=1
  120. 1200 IF Z=-1 THEN COLOR 1:PRINT USING"##";G:Y(Y,G)=-1
  121. 1210 G=0
  122. 1220 LOCATE 0,19:PRINT"                       "
  123. 1230 COLOR 7:GOTO *SELECT
  124. 1240 IF Z=1 THEN 320
  125. 1250 IF Z=-1 THEN Y=Y+1:GOTO 270
  126. 1260 Y=Y-1:GOTO 270
  127. 1270 '----- ソシオグラム -----
  128. 1280 LOCATE 0,19:INPUT"ソシオグラムを表示しますか (Y/N) ";Y$
  129. 1290 IF Y$="Y" OR Y$="y" THEN 1300 ELSE 1560
  130. 1300 LOCATE 0,19:PRINT SPACE$(70)
  131. 1310 LOCATE 0,19:PRINT"選択、排除を実線で結びます。          "
  132. 1320 BEEP:FOR I=1 TO 5000:NEXT
  133. 1330 CONSOLE 0,24,0:CLS:GOSUB 1590
  134. 1340 FOR P=1 TO W:FOR Q=1 TO W
  135. 1350   IF Y(P,Q)<>1 OR Q<P THEN 1410
  136. 1360   X1=210*COS(3.14159!/180*O*P)+330:Y1=190-160*SIN(3.14159!/180*O*P)
  137. 1370   X2=210*COS(3.14159!/180*O*Q)+330:Y2=190-160*SIN(3.14159!/180*O*Q)
  138. 1380   LINE(X1,Y1)-((X1+X2)/2,(Y1+Y2)/2),PSET,7,,&HFFFF
  139. 1390   IF Y(Q,P)=1 THEN LINE((X1+X2)/2,(Y1+Y2)/2)-(X2,Y2),PSET,7,,&HFFFF:GOTO 1410
  140. 1400   LINE((X1+X2)/2,(Y1+Y2)/2)-(X2,Y2),PSET,7,,&H6666
  141. 1410 NEXT Q,P
  142. 1420 LOCATE 0,0:INPUT"印刷しますか(Y/N) ";Y$
  143. 1430 IF Y$="Y" OR Y$="y" THEN LOCATE 0,0:PRINT SPACE$(70) ELSE 1440
  144. 1435 LOCATE 0,0:PRINT"< 選択 > ";TI$:HARDC 4
  145. 1440 CLS:GOSUB 1590
  146. 1450 COLOR 7
  147. 1460 FOR P=1 TO W:FOR Q=1 TO W
  148. 1470   IF Y(P,Q)<>-1 OR Q<P THEN 1530
  149. 1480   X1=210*COS(3.14159!/180*O*P)+330:Y1=190-160*SIN(3.14159!/180*O*P)
  150. 1490   X2=210*COS(3.14159!/180*O*Q)+330:Y2=190-160*SIN(3.14159!/180*O*Q)
  151. 1500   LINE(X1,Y1)-((X1+X2)/2,(Y1+Y2)/2),PSET,7,,&HFFFF
  152. 1510   IF Y(Q,P)=-1 THEN LINE((X1+X2)/2,(Y1+Y2)/2)-(X2,Y2),PSET,7,,&HFFFF:GOTO 1530
  153. 1520   LINE((X1+X2)/2,(Y1+Y2)/2)-(X2,Y2),PSET,7,,&H6666
  154. 1530 NEXT Q,P
  155. 1540 LOCATE 0,0:INPUT"印刷しますか (Y/N) ";Y$
  156. 1550 IF Y$="Y" OR Y$="y" THEN LOCATE 0,0:PRINT SPACE$(70) ELSE 1560
  157. 1555 LOCATE 0,0:PRINT"< 排除 > ";TI$:HARDC 4
  158. 1560 BEEP
  159. 1570 Y$="":Y=1:CLS 3:CONSOLE 0,24,1:RETURN 220
  160. 1580 '----- RING -----
  161. 1590 COLOR 1:O=340/W:P=1:Q=1:CO=1
  162. 1600 FOR A=1 TO W
  163. 1610 X1=INT(240*COS(3.14159!/180*O*A)+320)
  164. 1620 Y1=INT(180-176*SIN(3.14159!/180*O*A))
  165. 1630 SYMBOL@(X1,Y1),N$(A),1,1,2,0,OR
  166. 1640 IF A=M THEN CO=2
  167. 1650 NEXT A
  168. 1660 RETURN
  169. 1670 '----- ADD NAME ----
  170. 1680 IF W>47 THEN 950
  171. 1690 LOCATE 0,19:INPUT"転入者追加。追加する個人名は";H$
  172. 1700 IF H$="" THEN 1920
  173. 1710 LOCATE 0,19:PRINT SPACE$(70)
  174. 1720 LOCATE 0,19:INPUT"何番の後に挿入しますか";I$
  175. 1730 I=VAL(I$)
  176. 1740 IF I>W THEN H$="":I$="":GOTO 1920
  177. 1750 FOR A=W+1 TO I+2 STEP -1
  178. 1760 N$(A)=N$(A-1)
  179. 1770 NEXT A
  180. 1780 FOR P=W+1 TO I+2 STEP -1
  181. 1790 FOR Q=W+1 TO I STEP -1
  182. 1800  Y(P,Q)=Y(P-1,Q)
  183. 1810 NEXT Q,P
  184. 1820 FOR Q=W+1 TO I+2 STEP -1
  185. 1830 FOR P=W+1 TO 1 STEP -1
  186. 1840 Y(P,Q)=Y(P,Q-1)
  187. 1850 NEXT P,Q
  188. 1860 FOR A=1 TO W+1
  189. 1870 Y(I+1,A)=0:Y(A,I+1)=0
  190. 1880 NEXT A
  191. 1890 IF I=<M THEN M=M+1
  192. 1900 W=W+1
  193. 1910 N$(I+1)=H$:H$="":I$=""
  194. 1920 LOCATE 0,19:PRINT SPACE$(70):RETURN 210
  195. 1930 '----- ERASE -----
  196. 1940 LOCATE 0,19:INPUT"転出者削除。何番を削除しますか";E$
  197. 1950 IF E$="" THEN 2120
  198. 1960 E=VAL(E$)
  199. 1970 FOR A=E TO W-1
  200. 1980 N$(A)=N$(A+1)
  201. 1990 NEXT A
  202. 2000 N$(W+1)=""
  203. 2010 FOR P=E TO W-1:FOR Q=1 TO W-1
  204. 2020 Y(P,Q)=Y(P+1,Q)
  205. 2030 NEXT Q,P
  206. 2040 FOR Q=E TO W-1:FOR P=1 TO W-1
  207. 2050 Y(P,Q)=Y(P,Q+1)
  208. 2060 NEXT P,Q
  209. 2070 FOR A=1 TO W+1
  210. 2080 Y(A,W)=0:Y(W,A)=0
  211. 2090 NEXT A
  212. 2100 IF E=<M THEN M=M-1
  213. 2110 W=W-1:E$=""
  214. 2120 LOCATE 0,19:PRINT SPACE$(70):RETURN 210
  215. 2130 '----- DEBUG -----
  216. 2140 LOCATE 0,19
  217. 2150 INPUT"データ修正。何番ですか。";T$
  218. 2160 IF T$="" THEN 2260
  219. 2170 N=VAL(T$)
  220. 2180 IF N<1 OR N>W THEN T$="":GOTO 2260
  221. 2190 Y(Y,N)=0
  222. 2200 IF N<=(L-4) THEN LOCATE 0,N+4:GOTO 2250
  223. 2210 IF N<=M THEN LOCATE 19,N-L+8:GOTO 2250
  224. 2220 IF N<=(M+L-4) THEN LOCATE 38,N-M+4:GOTO 2250
  225. 2230 IF N>W THEN GOTO 2260
  226. 2240 LOCATE 57,N-M-L+8
  227. 2250 PRINT USING"##";N:T$="":N=0
  228. 2260 LOCATE 0,19:PRINT SPACE$(70)
  229. 2270 RETURN
  230. 2280 '----- 初期設定 -----
  231. 2290 *INITIALIZE
  232. 2300 COLOR 5:LINE(0,0)-(639,100),PSET,,B,&H8888:PRINT
  233. 2310 PRINT"                            ソシオメトリー"
  234. 2320 PRINT:PRINT"                            製作  後藤勝美"
  235. 2330 PRINT:PRINT
  236. 2340 PRINT:PRINT:COLOR 7
  237. 2350 INPUT"クラスの人数は  ";W
  238. 2360 INPUT"男子の人数は    ";M
  239. 2370 DIM Y(50,50),M$(48),N$(48),C(48),R(48),CRS(48)
  240. 2380 LINE(0,0)-(639,100),PRESET,,B:PRINT:PRINT"1:名簿を読み込む "
  241. 2390 PRINT"2:これから入力する    "
  242. 2400 COLOR 2:INPUT"どちらですか？番号を入力して下さい。";C$:COLOR 7
  243. 2410 IF C$="1" THEN 2700
  244. 2420 IF C$="2" THEN 2430 ELSE 2400
  245. 2430 BEEP:COLOR 2:PRINT:PRINT"名前を出席番号順に入力して下さい。漢字なら１人３文字以内にすると見易いです。"
  246. 2440 COLOR 5:PRINT:PRINT"〈  * を入力すると１つ前に戻ります 〉":COLOR 7,0
  247. 2450 FOR A=1 TO W
  248. 2460 PRINT USING"##";A;
  249. 2470 INPUT M$(A)
  250. 2480 IF M$(A)="*" THEN A=A-2 ELSE 2510
  251. 2490 IF A=-1 THEN 2450
  252. 2500 IF A=0 THEN 2450 ELSE 2520
  253. 2510 N$(A)=LEFT$(M$(A),10)
  254. 2520 NEXT
  255. 2530 PRINT:INPUT"登録しますか(Y/N)";B$
  256. 2540 IF B$="Y" OR B$="y" THEN 2550 ELSE RETURN
  257. 2550 INPUT"ファイル名は";F$
  258. 2560 OPEN F$ FOR OUTPUT AS #1
  259. 2570 FOR A=1 TO W:PRINT #1,N$(A):NEXT A
  260. 2580 CLOSE:BEEP:PRINT"終りました":RETURN
  261. 2590 '----- SAVE NAME DATA -----
  262. 2600 LOCATE 0,19:INPUT"名前を登録しますか(Y/N) ";Y$
  263. 2610 IF Y$="Y" OR Y$="y" THEN 2620 ELSE 2670
  264. 2620 LOCATE 0,19:PRINT SPACE$(70)
  265. 2630 LOCATE 0,19:INPUT"ファイル名は";F$
  266. 2640 OPEN F$ FOR OUTPUT AS #1
  267. 2650 FOR A=1 TO W:PRINT #1,N$(A):NEXT
  268. 2660 CLOSE:BEEP
  269. 2670 LOCATE 0,19:PRINT SPACE$(70)
  270. 2680 Y$="":RETURN
  271. 2690 '----- LOAD DATA -----
  272. 2700 FILES:COLOR 2:PRINT"これがドライブ０のファイル一覧表です。この中から選んで下さい。":COLOR 7
  273. 2710 INPUT"ファイル名は";F$
  274. 2720 OPEN F$ FOR INPUT AS #1
  275. 2730 FOR A=1 TO W:INPUT #1,N$(A):NEXT
  276. 2740 CLOSE:BEEP:PRINT
  277. 2750 INPUT"データを読み込みますか(Y/N)";D$
  278. 2760 IF D$="Y" OR D$="y" THEN 2770 ELSE RETURN
  279. 2770 INPUT"ファイル名は";F$
  280. 2780 OPEN F$ FOR INPUT AS #1
  281. 2790 FOR X=1 TO W:FOR Y=1 TO W
  282. 2800 INPUT #1,Y(X,Y)
  283. 2810 NEXT Y,X
  284. 2820 CLOSE:D$="":BEEP:CLS:RETURN
  285. 2830 '----- SAVE DATA -----
  286. 2840 LOCATE 0,19
  287. 2850 INPUT"データを登録しますか(Y/N) ";Y$
  288. 2860 IF Y$="Y" OR Y$="y" THEN 2870 ELSE 2940
  289. 2870 LOCATE 0,19:PRINT SPACE$(70)
  290. 2880 LOCATE 0,19:INPUT"ファイル名は ";F$
  291. 2890 OPEN F$ FOR OUTPUT AS #1
  292. 2900 FOR X=1 TO W:FOR Y=1 TO W
  293. 2910 PRINT #1,Y(X,Y)
  294. 2920 NEXT Y,X
  295. 2930 CLOSE:D$="":BEEP:RETURN
  296. 2940 LOCATE 0,19:PRINT SPACE$(70)
  297. 2950 Y$="":RETURN
  298. 2960 '----- 調査表 ----------------
  299. 2970 *TYOUSA
  300. 2980 LOCATE 0,0:PRINT"友だちしらべ     (   番   氏名                    )"
  301. 2990 PRINT:PRINT"おなじはんになりたい人･･･････○（";D;"人まで）              "
  302. 3000 PRINT"おなじはんになりたくない人･･･×（";D;"人まで）                    "
  303. 3010 PRINT"                                                         "
  304. 3020 LOCATE 0,18:PRINT"＊他の人のを見ないで、だまって書きなさい。"
  305. 3030 PRINT"＊あてはまる人がいなければ、書かなくてよい。"
  306. 3040 PRINT"＊出席番号順に提出しなさい。"
  307. 3050 HARDC 4:S$="":CONSOLE 0,24,1:GOTO 220
  308. 3060 '----- PROGRUM END -------------
  309. 3070 *END
  310. 3080 LOCATE 0,19:INPUT"プログラムを終わりますか (Y/N)";Y$
  311. 3090 IF Y$="Y" OR Y$="y" THEN 3100 ELSE 3110
  312. 3100 CLS:END
  313. 3110 LOCATE 0,19:PRINT SPACE$(79):GOTO *SELECT
  314.